home *** CD-ROM | disk | FTP | other *** search
/ Shareware Super Platinum 8 / Shareware Super Platinum 8.iso / mac / WIN_PRO / DS-1.ZIP;1 / RUNTIME.ZIP / RCOMP.R < prev    next >
Encoding:
Text File  |  1992-02-10  |  12.0 KB  |  519 lines
  1. /*
  2.  * File: rcomp.r
  3.  *  Contents: anycmp, equiv, lexcmp
  4.  */
  5.  
  6. /*
  7.  * anycmp - compare any two objects.
  8.  */
  9.  
  10. int anycmp(dp1,dp2)
  11. dptr dp1, dp2;
  12.    {
  13.    register int o1, o2;
  14.    register long lresult;
  15.    int iresult;
  16.    double rres1, rres2, rresult;
  17.  
  18.    /*
  19.     * Get a collating number for dp1 and dp2.
  20.     */
  21.    o1 = order(dp1);
  22.    o2 = order(dp2);
  23.  
  24.    /*
  25.     * If dp1 and dp2 aren't of the same type, compare their collating numbers.
  26.     */
  27.    if (o1 != o2)
  28.       return (o1 > o2 ? Greater : Less);
  29.  
  30.    if (o1 == 3)
  31.       /*
  32.        * dp1 and dp2 are strings, use lexcmp to compare them.
  33.        */
  34.       return lexcmp(dp1,dp2);
  35.  
  36.    switch (Type(*dp1)) {
  37.  
  38. #ifdef LargeInts
  39.  
  40.       case T_Integer:
  41.      if (Type(*dp2) != T_Lrgint) {
  42.         lresult = IntVal(*dp1) - IntVal(*dp2);
  43.         if (lresult == 0)
  44.            return Equal;
  45.         return ((lresult > 0) ? Greater : Less);
  46.         }
  47.      /* if dp2 is a Lrgint, flow into next case */
  48.  
  49.       case T_Lrgint:
  50.      lresult = bigcmp(dp1, dp2);
  51.      if (lresult == 0)
  52.         return Equal;
  53.      return ((lresult > 0) ? Greater : Less);
  54.  
  55. #else                    /* LargeInts */
  56.  
  57.       case T_Integer:
  58.      lresult = IntVal(*dp1) - IntVal(*dp2);
  59.      if (lresult == 0)
  60.         return Equal;
  61.      return ((lresult > 0) ? Greater : Less);
  62.  
  63. #endif                    /* LargeInts */
  64.  
  65.       case T_Coexpr:
  66.          /*
  67.           * Collate on co-expression id.
  68.           */
  69.          lresult = (BlkLoc(*dp1)->coexpr.id - BlkLoc(*dp2)->coexpr.id);
  70.          if (lresult == 0)
  71.             return Equal;
  72.          return ((lresult > 0) ? Greater : Less);
  73.  
  74.       case T_Cset:
  75.          return csetcmp((unsigned int *)((struct b_cset *)BlkLoc(*dp1))->bits,
  76.             (unsigned int *)((struct b_cset *)BlkLoc(*dp2))->bits);
  77.  
  78.       case T_File:
  79.          /*
  80.           * Collate on file name.
  81.           */
  82.          return lexcmp(&(BlkLoc(*dp1)->file.fname),
  83.             &(BlkLoc(*dp2)->file.fname));
  84.  
  85.       case T_List:
  86.          /*
  87.           * Collate on list id.
  88.           */
  89.          lresult = (BlkLoc(*dp1)->list.id - BlkLoc(*dp2)->list.id);
  90.          if (lresult == 0)
  91.             return Equal;
  92.          return ((lresult > 0) ? Greater : Less);
  93.  
  94.       case T_Null:
  95.          return Equal;
  96.  
  97.       case T_Proc:
  98.          /*
  99.           * Collate on procedure name.
  100.           */
  101.          return lexcmp(&(BlkLoc(*dp1)->proc.pname),
  102.             &(BlkLoc(*dp2)->proc.pname));
  103.  
  104.       case T_Real:
  105.          GetReal(dp1,rres1);
  106.          GetReal(dp2,rres2);
  107.          rresult = rres1 - rres2;
  108.      if (rresult == 0.0)
  109.         return Equal;
  110.      return ((rresult > 0.0) ? Greater : Less);
  111.  
  112.       case T_Record:
  113.          /*
  114.           * Collate on record id within record name.
  115.           */
  116.          iresult = lexcmp(&(BlkLoc(*dp1)->record.recdesc->proc.pname),
  117.             &(BlkLoc(*dp2)->record.recdesc->proc.pname));
  118.          if (iresult == Equal) {
  119.             lresult = (BlkLoc(*dp1)->record.id - BlkLoc(*dp2)->record.id);
  120.             if (lresult == 0)
  121.                return Equal;
  122.             return ((lresult > 0) ? Greater : Less);
  123.             }
  124.         return iresult;
  125.  
  126.       case T_Set:
  127.          /*
  128.           * Collate on set id.
  129.           */
  130.          lresult = (BlkLoc(*dp1)->set.id - BlkLoc(*dp2)->set.id);
  131.          if (lresult == 0)
  132.             return Equal;
  133.          return ((lresult > 0) ? Greater : Less);
  134.  
  135.       case T_Table:
  136.          /*
  137.           * Collate on table id.
  138.           */
  139.          lresult = (BlkLoc(*dp1)->table.id - BlkLoc(*dp2)->table.id);
  140.          if (lresult == 0)
  141.             return Equal;
  142.          return ((lresult > 0) ? Greater : Less);
  143.  
  144.       case T_External:
  145.      /*
  146.           * Collate these values according to the relative positions of
  147.           *  their blocks in the heap.
  148.       */
  149.          lresult = ((long)BlkLoc(*dp1) - (long)BlkLoc(*dp2));
  150.          if (lresult == 0)
  151.             return Equal;
  152.          return ((lresult > 0) ? Greater : Less);
  153.  
  154.       default:
  155.      syserr("anycmp: unknown datatype.");
  156.       }
  157.    }
  158.  
  159. /*
  160.  * order(x) - return collating number for object x.
  161.  */
  162.  
  163. int order(dp)
  164. dptr dp;
  165.    {
  166.    if (Qual(*dp))
  167.       return 3;          /* string */
  168.    switch (Type(*dp)) {
  169.       case T_Null:
  170.      return 0;
  171.       case T_Integer:
  172.      return 1;
  173.  
  174. #ifdef LargeInts
  175.       case T_Lrgint:
  176.      return 1;
  177. #endif                    /* LargeInts */
  178.  
  179.       case T_Real:
  180.      return 2;
  181.       case T_Cset:
  182.      return 4;
  183.       case T_Coexpr:
  184.      return 5;
  185.       case T_File:
  186.      return 6;
  187.       case T_Proc:
  188.      return 7;
  189.       case T_List:
  190.      return 8;
  191.       case T_Table:
  192.      return 9;
  193.       case T_Set:
  194.      return 10;
  195.       case T_Record:
  196.      return 11;
  197.       case T_External:
  198.          return 12;
  199.       default:
  200.      syserr("order: unknown datatype.");
  201.       }
  202.    }
  203.  
  204. /*
  205.  * equiv - test equivalence of two objects.
  206.  */
  207.  
  208. int equiv(dp1, dp2)
  209. dptr dp1, dp2;
  210.    {
  211.    register int result;
  212.    register word i;
  213.    register char *s1, *s2;
  214.    double rres1, rres2;
  215.  
  216.    result = 0;
  217.  
  218.       /*
  219.        * If the descriptors are identical, the objects are equivalent.
  220.        */
  221.    if (EqlDesc(*dp1,*dp2))
  222.       result = 1;
  223.    else if (Qual(*dp1) && Qual(*dp2)) {
  224.  
  225.       /*
  226.        *  If both are strings of equal length, compare their characters.
  227.        */
  228.  
  229.       if ((i = StrLen(*dp1)) == StrLen(*dp2)) {
  230.  
  231.  
  232.      s1 = StrLoc(*dp1);
  233.      s2 = StrLoc(*dp2);
  234.      result = 1;
  235.      while (i--)
  236.        if (*s1++ != *s2++) {
  237.           result = 0;
  238.           break;
  239.           }
  240.  
  241.      }
  242.       }
  243.    else if (dp1->dword == dp2->dword)
  244.       switch (Type(*dp1)) {
  245.      /*
  246.       * For integers and reals, just compare the values.
  247.       */
  248.      case T_Integer:
  249.         result = (IntVal(*dp1) == IntVal(*dp2));
  250.         break;
  251.  
  252. #ifdef LargeInts
  253.      case T_Lrgint:
  254.         result = (bigcmp(dp1, dp2) == 0);
  255.         break;
  256. #endif                    /* LargeInts */
  257.  
  258.  
  259.      case T_Real:
  260.             GetReal(dp1, rres1);
  261.             GetReal(dp2, rres2);
  262.             result = (rres1 == rres2);
  263.         break;
  264.  
  265.      case T_Cset:
  266.         /*
  267.          * Compare the bit arrays of the csets.
  268.          */
  269.         result = 1;
  270.         for (i = 0; i < CsetSize; i++)
  271.            if (BlkLoc(*dp1)->cset.bits[i] != BlkLoc(*dp2)->cset.bits[i]) {
  272.           result = 0;
  273.           break;
  274.           }
  275.      }
  276.    else
  277.       /*
  278.        * dp1 and dp2 are of different types, so they can't be
  279.        *  equivalent.
  280.        */
  281.       result = 0;
  282.  
  283.    return result;
  284.    }
  285.  
  286. /*
  287.  * lexcmp - lexically compare two strings.
  288.  */
  289.  
  290. int lexcmp(dp1, dp2)
  291. dptr dp1, dp2;
  292.    {
  293.  
  294.  
  295.    register char *s1, *s2;
  296.    register word minlen;
  297.    word l1, l2;
  298.  
  299.    /*
  300.     * Get length and starting address of both strings.
  301.     */
  302.    l1 = StrLen(*dp1);
  303.    s1 = StrLoc(*dp1);
  304.    l2 = StrLen(*dp2);
  305.    s2 = StrLoc(*dp2);
  306.  
  307.    /*
  308.     * Set minlen to length of the shorter string.
  309.     */
  310.    minlen = Min(l1, l2);
  311.  
  312.    /*
  313.     * Compare as many bytes as are in the smaller string.  If an
  314.     *  inequality is found, compare the differing bytes.
  315.     */
  316.    while (minlen--)
  317.       if (*s1++ != *s2++)
  318.  
  319.          return (ToAscii(*--s1 & 0377) > ToAscii(*--s2 & 0377) ?
  320.                  Greater : Less);
  321.    /*
  322.     * The strings compared equal for the length of the shorter.
  323.     */
  324.    if (l1 == l2)
  325.       return Equal;
  326.    else if (l1 > l2)
  327.       return Greater;
  328.    else
  329.       return Less;
  330.  
  331.    }
  332.  
  333. #ifdef Never  /* #%#% */
  334. #define RetError(x,y) return Error    /* #%#% needs attention */
  335. /*
  336.  * numcmp - compare two numbers.  Returns -1, 0, 1 for dp1 <, =, > dp2.
  337.  *  dp3 is made into a descriptor for the return value.
  338.  */
  339.  
  340. int numcmp(dp1, dp2, dp3)
  341. dptr dp1, dp2, dp3;
  342.    {
  343.    int t1, t2;
  344.    double r1, r2;
  345.    /*
  346.     * Be sure that both dp1 and dp2 are numeric.
  347.     */
  348.  
  349.    if ((t1 = cvnum(dp1)) == CvtFail)
  350.       RetError(102, *dp1);
  351.    if ((t2 = cvnum(dp2)) == CvtFail)
  352.       RetError(102, *dp2);
  353.  
  354.    if (t1 == T_Integer && t2 == T_Integer) {
  355.    /*
  356.     *  dp1 and dp2 are both integers, compare them and
  357.     *  create an integer descriptor in dp3
  358.     */
  359.  
  360.       *dp3 = *dp2;
  361.       if (IntVal(*dp1) == IntVal(*dp2))
  362.      return Equal;
  363.       return ((IntVal(*dp1) > IntVal(*dp2)) ? Greater : Less);
  364.       }
  365.    else if (t1 == T_Real || t2 == T_Real) {
  366.  
  367.    /*
  368.     *  Either dp1 or dp2 is real. Convert the other to a real,
  369.     *  compare them and create a real descriptor in dp3.
  370.     */
  371.  
  372.       if (t1 != T_Real) {
  373.  
  374. #ifdef LargeInts
  375.      if (t1 == T_Lrgint)
  376.         r1 = bigtoreal(dp1);
  377.      else
  378. #endif                    /* LargeInts */
  379.  
  380.             r1 = IntVal(*dp1);
  381.  
  382.          }
  383.       else
  384.  
  385. #ifdef Double
  386.     {
  387.         int    *rp, *rq;
  388.         rp = (word *) &(BlkLoc(*dp1)->realblk.realval);
  389.         rq = (word *) &r1;
  390.         *rq++ = *rp++;
  391.         *rq = *rp;
  392.     }
  393. #else                    /* Double */
  394.      r1 = BlkLoc(*dp1)->realblk.realval;
  395. #endif                    /* Double */
  396.  
  397.       if (t2 != T_Real) {
  398.  
  399. #ifdef LargeInts
  400.      if (t2 == T_Lrgint)
  401.         r2 = bigtoreal(dp2);
  402.      else
  403. #endif                    /* LargeInts */
  404.  
  405.             r2 = IntVal(*dp2);
  406.          }
  407.       else
  408.  
  409. #ifdef Double
  410.     {
  411.         int    *rp, *rq;
  412.         rp = (word *) &(BlkLoc(*dp2)->realblk.realval);
  413.         rq = (word *) &r2;
  414.         *rq++ = *rp++;
  415.         *rq = *rp;
  416.     }
  417. #else                    /* Double */
  418.      r2 = BlkLoc(*dp2)->realblk.realval;
  419. #endif                    /* Double */
  420.      
  421.       if (makereal(r2, dp3) == Error)
  422.          return Error;        /* #%#%  should be RetError??? */ 
  423.       if (r1 == r2)
  424.      return Equal;
  425.       return ((r1 > r2) ? Greater : Less);
  426.       }
  427.  
  428. #ifdef LargeInts
  429.    else {
  430.       int result;
  431.  
  432.       *dp3 = *dp2;
  433.       result = bigcmp(dp1, dp2);
  434.       if (result == 0)
  435.      return Equal;
  436.       return ((result > 0) ? Greater : Less);
  437.       }
  438. #endif                    /* LargeInts */
  439.    }
  440. #endif                    /* !COMPILER */
  441.  
  442. /*
  443.  * csetcmp - compare two cset bit arrays.
  444.  *  The order defined by this function is identical to the lexical order of
  445.  *  the two strings that the csets would be converted into.
  446.  */
  447.  
  448. int csetcmp(cs1, cs2)
  449. unsigned int *cs1, *cs2;
  450.    {
  451.    unsigned int nbit, mask, *cs_end;
  452.  
  453.    if (cs1 == cs2) return Equal;
  454.  
  455.    /*
  456.     * The longest common prefix of the two bit arrays converts to some
  457.     *  common prefix string.  The first bit on which the csets disagree is
  458.     *  the first character of the conversion strings that disagree, and so this
  459.     *  is the character on which the order is determined.  The cset that has
  460.     *  this first non-common bit = one, has in that position the lowest
  461.     *  character, so this cset is lexically least iff the other cset has some
  462.     *  following bit set.  If the other cset has no bits set after the first
  463.     *  point of disagreement, then it is a prefix of the other, and is therefor
  464.     *  lexically less.
  465.     *
  466.     * Find the first word where cs1 and cs2 are different.
  467.     */
  468.    for (cs_end = cs1 + CsetSize; cs1 < cs_end; cs1++, cs2++)
  469.       if (*cs1 != *cs2) {
  470.      /*
  471.       * Let n be the position at which the bits first differ within
  472.       *  the word.  Set nbit to some integer for which the nth bit
  473.       *  is the first bit in the word that is one.  Note here and in the
  474.       *  following, that bits go from right to left within a word, so
  475.       *  the _first_ bit is the _rightmost_ bit.
  476.       */
  477.      nbit = *cs1 ^ *cs2;
  478.  
  479.      /* Set mask to an integer that has all zeros in bit positions
  480.       *  upto and including position n, and all ones in bit positions
  481.       *  _after_ bit position n.
  482.       */
  483.      for (mask = (unsigned)MaxLong << 1; !(~mask & nbit); mask <<= 1);
  484.  
  485.      /*
  486.       * nbit & ~mask contains zeros everywhere except position n, which
  487.       *  is a one, so *cs2 & (nbit & ~mask) is non-zero iff the nth bit
  488.       *  of *cs2 is one.
  489.       */
  490.      if (*cs2 & (nbit & ~mask)) {
  491.         /*
  492.          * If there are bits set in cs1 after bit position n in the
  493.          *  current word, then cs1 is lexically greater than cs2.
  494.          */
  495.         if (*cs1 & mask) return Greater;
  496.         while (++cs1 < cs_end)
  497.            if (*cs1) return Greater;
  498.  
  499.         /*
  500.          * Otherwise cs1 is a proper prefix of cs2 and is therefore
  501.          *  lexically less.
  502.          */
  503.          return Less;
  504.          }
  505.  
  506.      /*
  507.       * If the nth bit of *cs2 isn't one, then the nth bit of cs1
  508.       *  must be one.  Just reverse the logic for the previous
  509.       *  case.
  510.       */
  511.      if (*cs2 & mask) return Less;
  512.      cs_end = cs2 + (cs_end - cs1);
  513.      while (++cs2 < cs_end)
  514.         if (*cs2) return Less;
  515.      return Greater;
  516.      }
  517.    return Equal;
  518.    }
  519.